Shareware Grab Bag/Shareware Grab Bag.iso/013/vtree2.arc/VTREE2.DOC

Text File | 1986-12-25 | 15.9 KB | 409 lines

(* VTREE  -  Written Feb 5, 1986 By Vinnie Finn
                                   137 Falmouth St.
                                   Rochester, NY 14615
                                   [phone]
             Modified Oct 11, 1986 By Vinnie Finn
             add lines to output and enable output redirection.

  Recursive Program to display the tree structure of a disk.
  can be modified to perform  -  Where   { Modify FileName='*.*' to input parameter}
                                         { and Atrribute to 255 }
                                 Tree/F  { Write All fileNames,Size,Date&Time}
                                 Treed - { With Lines }

  This was written after curiousity was sparked by the TREED.EXE Program,
  which performed the same way this program does but did not provide
  code. I feel apprehensive about getting hooked on any code that can not
  be modified by the user.

  Input parameter optional. Include path and directory of Tree to start
  with, defaults to Root.

  I believe that the best way to learn program techniques, is to study
  others programs.  I'm sure that this code is not the cleanest in the
  world, so If anyone modifys it, I would appreciate a copy.
  Upload the new file to Station Rochester, Rochester, NY.  The number
  is [phone] Dave Stanwix,  Sysop.

  This program is put in the public domain under the shareware concept.
  If you feel this program is worth a financial contribution to the
  development of new software, send a contribution of $3.00 or more to
  my address above.  You will then be a registered owner and will be
  informed of new software releases for Vtree and more, as soon as they
  are available.  Thanks again, and remember... The Shareware concept is
  users SUPPORTING users !!  Any comments about the software can be left
  on Station Rochester PCBoard and will receive a prompt reply.

  The speed of this program can be enhanced by changing the stack structure
  to a forward and backward, linked list. I just thought I'd play with a
  recursive search (Dig).

  Redirection of Output may be used. This means that you can run this
  program and redirect the output to the printer or a file or any other
  device. The standard DOS format for this is application would be:
  VTREE2>PRT
  or
  VTREE2>FileName.ext
  and to append it to the end of a document or file.
  VTREE2>>Filename.Ext
*)
{$P512}     { Enable Output re-direction }
{$C-}       { Disable Control C }

Program VTree2;
{****************************************************************************}
{                  F I L E         S U B R O U T I N E S                     }
{****************************************************************************}
  Const   Hor  = '─';
          Ver  = '│';
          T    = '┬';
          ST   = '├';
          L    = '└';
          Symbols : Array[Boolean,Boolean] Of Char = (('└','├'),('─','┬'));
  Type
    RegisterSet=Record Case Integer Of
                  1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
                  2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
                End;
    DTAptr = ^Dir_Entry;
    Buff       = record
                      Reserved        : array[1..21] of byte;
                      Attribute       : byte;
                      Time,
                      Date,
                      FileSizeLo,
                      FileSizeHi      : integer;
                      Name            : string[13];
                  end;
    Dir_Entry   = Record
                     Dta      : Buff;
                     Level    : Byte;
                     Next_Ptr : DtaPtr;
                  End;
    FileName_Type  = String[64];
Var
    Reg       : RegisterSet;  { Dos Registers                              }
    TopBuff,                  { Pointer to the Top of The Linked list.     }
    BuffPtr,
    WorkPtr   : DtaPtr;       { Pointer to the current node within List.   }
    RetCode   : byte;         { Return code, contains error code if any.   }
    Tmp       : FileName_Type;{ Used to avoid collision.                   }
    I,                        { General purpose variable.                  }
    Fill_len  : Integer;      { Used to prohibit lines at end of line      }
    Err       : Byte;         { Flags error on directory change/get.       }
    PushDone  : Boolean;      { Tells if most recent thing done was a Push }
    LowLevel  : Byte;         { Tells level of current BuffPtr within      }
                              { linked list. How far from top.             }
    Line,
    Blank     : String[80];   { Contains Blanks.                           }


{****************************************************************************}
{                S  E  T       Disk  Transfer  Address                       }
{****************************************************************************}
Procedure Set_Disk_Trns_Addr(BuffPtr:DtaPtr);
Begin
  with Reg do
  begin
      Ax := $1A00;                     { Set disk transfer address to  }
      Ds := seg(BuffPtr^.dta);             { our disk buffer               }
      Dx := ofs(BuffPtr^.dta);
      MsDos(Reg);
  end;
end;

{****************************************************************************}
{                 P U S H   B U F F E R   O N T O   S T A C K                }
{****************************************************************************}
PROCEDURE PushBuff;    { Saves current DTA Area and sets up for a new one }
BEGIN
    PushDone:=True;
    new( BuffPtr^.Next_Ptr );
    BuffPtr:=BuffPtr^.Next_Ptr;
    If TopBuff=Nil Then TopBuff:=BuffPtr;
    LowLevel:=LowLevel+1;
    BuffPtr^.Level:=LowLevel;
    Set_Disk_Trns_Addr(BuffPtr);
END; {Push_Buff}

{****************************************************************************}
{            Dig down to the Lowest Level of the Heap                        }
{****************************************************************************}
Function Dig(Point:DtaPtr):DtaPtr;   { Recursive find of pointer }
Begin
   If Point^.Level>=LowLevel Then    { Go as deep as is the Heap }
      Dig:=Point
   Else
      Dig:=Dig(Point^.Next_Ptr);
End;

{****************************************************************************}
{                         Pop Prior DTA off the Heap                         }
{****************************************************************************}
PROCEDURE PopBuff;         { Pop off the previously Pushed DTA Area }
Var  FreePoint: DTAPtr;
BEGIN {RestoreBuff}
  FreePoint:=BuffPtr;
  PushDone:=False;
  Reg.AH:=$2F;
  MsDos(Reg);
  LowLevel:=LowLevel-1;
  BuffPtr:=Dig(TopBuff);
  Set_Disk_Trns_Addr(BuffPtr);
  Dispose(FreePoint);  { Free un-needed node on the Heap }
END; {Pop_Buff}




{****************************************************************************}
{                  F I N D   N E X T   F I L E   E N T R Y                   }
{****************************************************************************}
Procedure Find_Next(var Att:byte; var Filename : Filename_type;
                                      var Next_RetCode : byte);
var
  Carry_flag : integer;
  N          : byte;

Begin  {Find_Next}
  BuffPtr^.Dta.Name := '             ';     { Clear result buffer }
  With Reg do
  Begin
      Ax := $4F shl 8;                 { Dos Find next function }
      MsDos(Reg);
      Att := BuffPtr^.Dta.Attribute;         { Set file attribute     }
      Carry_flag := 1 and Flags;       { Isolate the Error flag }
      Filename := '             ';
      if Carry_flag = 1 then
        Next_RetCode := Ax and $00FF
      else
      begin                          { Move file name         }
        Next_RetCode := 0;
        for N := 0 to 12 do
           FileName[N+1] := BuffPtr^.Dta.Name[N];
      end;
  end;  {with}
end;
{****************************************************************************}
{              F I N D   F I R S T   F I L E   F U N C T I O N               }
{****************************************************************************}
Procedure Find_First (var Att: byte;
                      var Filename: Filename_type;
                      var RetCode_code : byte);

  var

      Carry_flag       :integer;
      Mask, N          :byte;

  begin
    Set_Disk_Trns_Addr(BuffPtr);
    Filename[length(Filename) + 1] := chr(0);
    BuffPtr^.Dta.Name := '             ';
    with Reg do
    begin
      Ax := $4E shl 8;                  { Dos Find First Function }
      Cx := Att;                        { Attribute of file to fine }
      Ds := seg(Filename);              { Ds:Dx Asciiz string to find }
      Dx := ofs(Filename) + 1;
      MsDos(Reg);
      Att := BuffPtr^.Dta.Attribute;          { set the file attribute byte  }
                 { If error occured set, Return code. }
      Carry_flag := 1 and Flags;      { If Carry flag, error occured }
                                        { and Ax will contain Return code }
      if Carry_flag = 1 then
          RetCode_code := Ax and $00FF
      else
      begin
          RetCode_code := 0;
          Filename := '             ';
          for N := 0 to 12 do
             FileName[N+1] := BuffPtr^.Dta.Name[N];
      end;
   End;
end;

{****************************************************************************}
{         Asciiz changes a IBM formatted string into an Asciiz formatted     }
{         string.  IBM = [Length]+[Ch]+[Ch]+[Ch]...                          }
{               AsciiZ = [Ch]+[Ch]+[Ch]...0                                  }
{****************************************************************************}
Procedure Asciiz(VAR Inp : FileName_Type);
VAR  L,Indx   : Integer;
Begin
   L:=Length(Inp);
   If L>0 Then
      For Indx:=0 to L-1 Do
         Inp[Indx]:=Inp[Indx+1];
   Inp[L]:=#0;
End;

{****************************************************************************}
{                  DOS Call for current directory and Path                   }
{****************************************************************************}
Function Get_Curr_Dir : FileName_Type;
begin
      Reg.AH:=$47;                 { Get Current directory }
      Reg.Ds:=Seg(Tmp);
      Reg.Si:=Ofs(Tmp)+1;     { Bypass the length Byte }
      Reg.DL:=$0;
      Msdos(Reg);
      If (Reg.Flags And 1)=1 Then  { Carry flag is set }
         Err:=Reg.AX
      Else
      Begin
         I:=1;
         While Tmp[I]<>#0 Do
            I:=I+1;
         Tmp[0]:=Chr(I);     { Adjust Length of string }
         Get_Curr_dir:=Tmp;
      End;
End;

{****************************************************************************}
{                  DOS Call to Change Current directory                      }
{****************************************************************************}
Procedure Change_Dir(Directory:FileName_Type);
Begin
    Tmp:=Directory;
    Asciiz(Tmp);
    Reg.AH:=$3B;
    Reg.DS:=Seg(Tmp);
    Reg.DX:=Ofs(Tmp);
    MsDos(Reg);
    If (Reg.Flags And 1)=1 Then  { Carry flag is set }
       Err:=Reg.AX;
End;


{****************************************************************************}
{                       P R O C E S S     D I R E C T O R Y                  }
{                                                                            }
{   This is a recursive program to  1) Make a New DTA working area           }
{                                   2) Find First  *                         }
{                                   3) Find Next   *                         }
{                                   4) Return to Prior DTA Stack condition.  }
{   *  If File=Directory  A) Write Directory Name.                           }
{                         B) Call Process Directory.                         }
{****************************************************************************}
var
  attribyte    : Byte;
  Curr_Dir,
  Save_Dir     : fileName_Type;

Procedure Process_Dir(Dir:FileName_Type);
Var      Filename  : FileName_Type;
         Lngth     : Integer;
         Curr_Sym  : Char;
         First     : Boolean;
    Procedure Hit_Check;
    Var Fil  : FileName_Type;
        Att,
        Ret  : Byte;
        Sym  : Char;
    Begin
       If (Retcode = 0)  then  { No error }
          { subdirectory only but not '.' or '..' }
          If (Attribyte=$10) AND (FileName[1]<>'.') Then
          Begin
             If (NOT PushDone) AND (LowLevel>1) Then
                Write(' ',Copy(Blank,1,10*(LowLevel-1))) { Tab over }
             Else
                If (LowLevel=1) And (Not First) Then
                   Write(' ')
                Else
                   Write(Hor);
             Lngth:=Pos(' ',FileName)-2;
             { The only way that I can figure out which lines are to be  }
             { used is to look ahead in the same directory for a Sub Dir.}
             { This slows down the program somewhat because it repeats   }
             { this find when we move down the DIR. But my brain was     }
             { turning to mush at this point. VTREE3 will contain the    }
             { enhancement that will avoid this duplicate processing.    }
             Att:=Attribyte;      { Do not destroy current Attributes    }
             Ret:=RetCode;
             Fil:=FileName;
             WorkPtr^.DTA:=BuffPtr^.DTA; { Copy current Buffer to work buffer }
             PushBuff;                   { Save Current buffer                }
             BuffPtr^.Dta:=WorkPtr^.Dta; { Copy previous buffer to current    }
             Repeat
                Find_Next(att,fil,Ret);
             Until (Att=$10) AND (Fil[1]<>'.') OR (Ret<>0);
             Sym:=Symbols[First,Ret=0];   { Quick way to do the following }
(*           If First Then
             Begin
                If Ret=0 Then    { No Error }
                   Sym:=T    { Is another Dir following }
                Else
                   Sym:=Hor; { End of Sub Dirs for this Dir }
             End
             Else
             Begin
                If Ret=0 Then
                   Sym:=St
                Else
                   Sym:=L;
             End;
*)
             Write(Copy(Line,1,Fill_len),Sym,Copy(Filename,1,Lngth));
             Fill_Len:=8-Lngth;
             PopBuff;          { Set current back to previous buffer }
             First:=False;
             Process_Dir(FileName);
             Fill_Len:=0;
          End;
    End; { Hit Check }
Begin
      PushBuff;
      Change_Dir(Dir);
      filename := '*.*' ;
      attribyte := $10;     { Normal + SubDirectories }
      Retcode:=0;
      First:=True;
      Find_First(attribyte,filename,Retcode);
      Hit_Check;
      {Now we repeat Find_Next until an error occurs }
      Repeat
         Find_Next(attribyte,filename,Retcode);
         Hit_Check;
      Until Retcode <> 0;    { Until Error = mostlikely error will be #18 (No More Files) }
      If PushDone Then WriteLn;
      PopBuff;                    { Back Out }
      Change_Dir('..');
      RetCode:=0;
End;


{***************************************************************************}
{                          M A I N    L I N E                               }
{***************************************************************************}

  begin
       New(WorkPtr);
       TopBuff:=Nil;
       BuffPtr:=Nil;
       For I:=1 to 80 Do
          Line[I]:=Hor;      { Maybe make it a constant ! }
       Blank[1]:=Ver;
       For I:=2 to 80 Do
          Blank[I]:=' ';
       Line[0]:=Chr(80);    { Set length }
       Blank[0]:=Chr(80);
       LowLevel:=0;
       Fill_Len:=0;
       ClrScr;
       Save_Dir:=Get_Curr_Dir;
       If (Reg.Flags And 1)=1 then Halt;
       Err:=0;
       If ParamCount>0 Then
       Begin
          Curr_Dir:=ParamStr(1);
          WriteLN(Curr_Dir);WriteLN;
       End
       Else
          Curr_Dir:='\';
       Process_Dir(Curr_Dir);
       Change_Dir('\'+Save_Dir);
       Dispose(WorkPtr);
  end.